MacTech 1 to 12

home *** CD-ROM | disk | FTP | other *** search

/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.07 Jul 89 / JamPaint ƒ / JamPaint.p < prev next >

Wrap

Text File | 1988-06-19 | 60.9 KB | 2,708 lines | [TEXT/MPS ]

Program JamPaint; { ************************************************* JamPaint -- the Network Paint Application ************************************************* Copyright 1988 by Edgar Circenis and Rod Magnuson All Rights Reserved ************************************************* Started: 12/26/87 Revision: 5/21/88 ************************************************* Problem areas: - Do we need to worry about nets as well as nodes? - How big should PQ be? - VBLTasks cannot move memory. - Change xEnqueue and xDequeue to access PQ directly. - What causes initial LAPWrite error @70 (err = -95)??? - NOTE: if we end up using polling, a queue will be unnecessary. - use VAR parameters where it will speed things up. ************************************************* } USES {$LOAD MacDump} Memtypes,Quickdraw,OSIntf,ToolIntf,PackIntf,PickerIntf,Script, {$LOAD AppleTalkDump} AppleTalk, {$LOAD MacPrintDump} PrintTraps; CONST lastMenu = 7; maxUsers = 8; { User Table size } OurType = 39; { a random LAP protocol type } listSize = 550; { incoming packet queue size } VBLcnt = 2; { myTask.vblCount } connect = false; spray = true; idleTime = 60*60*5; { five minute idle time } eraseCursor = 128; splatCursor = 8088; { splatter cursor ID } { ---- TOOLS ---- } Tnone = 0; { no tool, or special tool } Tspray = 1; { not really a tool! } TLetters = 2; { letter tool } Tbrush = 3; { paint brush } Terase = 4; { eraser } TRect = 5; { Rectangle } TFrect = 6; { Filled Rectangle } TOval = 7; { Oval } TFOval = 8; { Filled Oval } TSplatter= 9; { Splatter Tool } TDisk = 10; { Disk Access } Tpat = 11; { not a tool } Tcolor = 12; { not a tool } { ---- DEFAULTS ---- } dSize = 12; dStyle = []; dPen = 1; { 1 x 1 pen } dColor = 1; { black } dTool = Tbrush; dMode = connect; dsplatterCount = 30; { * default spatter speed * } dsplatRad = 20; { * default splatter radius * } { **** make a decision about this and then delete it **** } polling = true; { **** make a decision about this and then delete it **** } appleMenu = 1; fileMenu = 2; fontMenu = 3; sizeMenu = 4; styleMenu = 5; effectsMenu = 6; editMenu = 7; TYPE UserTableRec = record id :integer; { appleTalk id } time :longint; { idle time } theTool :integer; { current tool } x,y :integer; { mouse coordinates } theMode :boolean; { paint mode } thePat :pattern; { current pattern } theClr :RGBColor; { current color } hSize,vSize :integer; { penSize } theFnum :integer; { font number } theFsize :integer; { font size } theFstyle :style; { font style } splatRad :integer; { splatter tool's radius } splatSpeed :integer; { splatter tool's speed } end; MSGType = (paintMode,alpha,settool,eraseall,setpat,setcolor,setpen,setfont,setpos,drag,rectpck,setSplat,rqinfo,sendinfo); LAPMsg = record size :packed array [0..1] of byte; { packet length } theType :MSGType; { message type } id :byte; { node id } case MSGType of paintMode: (mode :boolean); { select paint mode type: connect, spray } alpha: (ch :char); { type char in current font, size, style, location } settool: (tool :integer); { select a tool } setpat: (pat :pattern); { select a pattern } setcolor: (clr :RGBColor); { select a color } setpen: (px,py:integer); { set pen size to px,py } setfont: (fnum :integer; { select font characteristics } fsize:integer; fstyl:style); setpos: (mx,my:integer); { set current position to mx,my } drag: (cx,cy:integer); { mouse dragged from mx,my to cx,cy } setSplat: (sRad:integer; { resize splatter tool } sSpeed:integer); rectpck: (rct :rect; { rectangle for TRect..TFOval } optDown:boolean); sendinfo: (info :UserTableRec);{ user info } end; LAPMsgPtr = ^LAPMsg; PacketList = Packed array [0..listSize-1] of LAPMsg; PacketQueue = record head :integer; tail :integer; queue :PacketList; end; PacketQueuePtr = ^PacketQueue; CArry = Array [1..8] of RGBColor; CPtr = ^CArry; CHandle = ^CPtr; BitMapPtr = ^BitMap; VAR { A NOTE ABOUT GLOBALS AND SUCH: Everyone and their brother is taught that using global variables is a sin. We do not agree. By using many globals and declaring parameters in parameter lists to be VAR parameters (even when not needed), we increase the speed of our code by reducing stack frame size and the creation of local copies of variables. } myEvent :EventRecord; theItem,theMenu,refnum :integer; theChar :Char; code :integer; tempWindow,myWindow :WindowPtr; doneflag :boolean; PrDebug :boolean; mods :longint; mymenus :array [1..lastmenu] of MenuHandle; FileMenuPresent :boolean; err :integer; dlg :DialogPtr; itype :integer; item :handle; box :rect; itemHit :integer; myTask :VBLTask; UT :array [0..maxUsers] of UserTableRec; PQ :PacketQueue; myNode,myNet :integer; LAPrh,LAPwh :ABRecHandle; LAPrbuf,LAPwbuf :LAPMsg; DrawWindow :WindowPtr; drect,prect :rect; jamPic,palette :picHandle; ToolRects :array[1..20] of Rect; curPatRect :rect; hSizeRect,vSizeRect :rect; PatternsUp :Boolean; thePatterns :array [1..8] of pattern; theColors :CArry; curPat,curColor :integer; theFontidx :integer; theSizeidx :integer; clickTime :longint; lastTool :integer; theECurs,theCurs :cursor; arrowCurs,updateCurs :boolean; bmap,Wbits :bitmap; oldRgn,oldClip :RgnHandle; changed,saved :boolean; fVref :integer; MultiFinderRunning :boolean; ColorQDrawImplm :boolean; MacII,PixDraw :boolean; myCGrafPtr :CGrafPtr; myCGrafPort :CGrafPort; ourCMHandle :CTabHandle; offpix,Wpix :PixMapHandle; theHand,theSizer :CursHandle; theSprayer,thePlacer :CursHandle; hPrint :THPrint; Procedure SendLAP(who:byte); Forward; Procedure CheckRead; Forward; Procedure DrawContents; Forward; Procedure Debug(s:str255); begin if PrDebug then begin PrCtlCall(iPrIOCtl,ord(@s)+1,length(s),0); PrCtlCall(iPrDevCtl,$0003FFFF,0,0); end; end; Function Str(i:longInt):str255; { These two functions are invaluable } begin NumToString(i,Str); end; Function Val(s:str255):longint; begin StringToNum(s,Val); end; function MyGetNextEvent(evtMask:Integer;VAR Evt:EventRecord):Boolean; { * This allows us to be more MultiFinder compatible * } begin If MultiFinderRunning then MyGetNextEvent:=WaitNextEvent(evtMask,Evt,15,Nil) else begin SystemTask; MyGetNextEvent:=GetNextEvent(evtMask,Evt); end; end; Procedure MenuString(s:str255); { good for debugging simple stuff } var dMenu :MenuHandle; begin s := Concat(s,' <click>'); DMenu := NewMenu(999,s); InsertMenu(DMenu,0); DrawMenuBar; sysBeep(1); repeat Until MyGetNextEvent(mdownMask+keyDownMask+AutoKeyMask,myEvent); DeleteMenu(999); DisposeMenu(DMenu); DrawMenuBar; end; Function idleFilter(item:Integer;theDlg:DialogPtr):Integer; begin SetUpA5; idleFilter:=item; CheckRead; RestoreA5; end; procedure HiliteButton(theDialog:DialogPtr); begin SetPort(theDialog); GetDItem(theDialog,ok,iType,iTem,Box); InsetRect(Box,-4,-4); PenSize(3,3); FrameRoundRect(box,15,16); PenNormal; end; Procedure DoErr(i:integer); begin if err<>0 then begin if prDebug then Debug(concat('*** ',str(i),': error = ',str(err))) else menuString(concat(str(i),': error = ',str(err))); end; end; Procedure RsrcErr; begin if ResError<>0 then begin if PrDebug then Debug(concat('*** RsrcErr=',str(ResError))) else menuString(concat('RsrcErr=',str(ResError))); end; end; Procedure SetUpMenus; var i :integer; s,fName :str255; begin InitMenus; FileMenuPresent:=false; for i := 1 to lastmenu do MyMenus[i] := GetMenu(254+i); for i := 1 to lastmenu-1 do InsertMenu(myMenus[i],0); AddResMenu(MyMenus[appleMenu],'DRVR'); AddResMenu(MyMenus[fontMenu],'FONT'); GetFontName(applFont,fName); for i := 1 to countMItems(mymenus[fontMenu]) do begin GetItem(mymenus[fontMenu],i,s); if s=fName then begin CheckItem(mymenus[fontMenu],i,true); theFontidx := i; leave; end; end; for i:=1 to 9 do begin GetItem(myMenus[sizeMenu],i,s); if RealFont(theFontidx,Val(s)) then SetItemStyle(myMenus[sizeMenu],i,[Outline]) else SetItemStyle(myMenus[sizeMenu],i,[]); end; DrawMenuBar; end; Procedure xEnqueue(var msg:LAPMsg); { add queue element } begin Debug('xEnqueue'); with PQ do if (tail+1) mod listSize = head then begin sysbeep(1); { oops, queue full! } Debug('Queue Full'); end else begin queue[tail] := msg; tail := (tail+1) mod listSize; Debug(concat(' head=',str(head),', tail=',str(tail))); end; end; Function xDequeue(var msg:LAPMsg):boolean; { remove first queue element } begin with PQ do if tail=head then xDequeue := false else begin Debug('xDequeue: dequeued'); msg := queue[head]; head := (head+1) mod listsize; xDequeue := true; Debug(concat(' head=',str(head),', tail=',str(tail))); end; end; procedure DoPageSetUp; var temphPrint : THPrint; err : OSErr; begin PrOpen; If PrError=noErr then begin temphPrint:=hPrint; err:=HandToHand(handle(temphPrint)); Repeat if PrStlDialog(temphPrint) then begin DisposHandle(handle(hPrint)); If MemError<>NoErr then SysBeep(1); hPrint:=temphPrint; err:=HandToHand(handle(hPrint)); if err<>NoErr then SysBeep(1); end; Until not PrValidate(hPrint); end; PrClose; DisposHandle(handle(temphPrint)); end; Function FindUser(id:integer):integer; { find a user's UT entry } { find user in UT. If not in UT, return -1 and send <rqinfo> packet to user if table not yet full. If data is not valid, returns -(index+1). } var i :integer; begin Debug('FindUser'); for i := 0 to maxUsers do { CASE 1: look for user } if UT[i].id=id then begin FindUser := i; { valid user found } Debug(' user found'); exit(FindUser); end; Debug(' user not found'); for i := 1 to maxUsers do { CASE 2: look for empty slot } if UT[i].id<0 then begin UT[i].id := id; LAPwbuf.theType := rqinfo; SendLAP(id); FindUser := -1; { user not valid (yet) } exit(FindUser); end; for i := 1 to maxUsers do { CASE 3: look for idle user } if tickCount-UT[i].time>idleTime then begin UT[i].id := id; LAPwbuf.theType := rqinfo; SendLAP(id); FindUser := -1; { user not valid (yet) } exit(FindUser); end; end; Procedure SetUserState(j:integer); { set previous user state } begin Debug('SetUserState'); with UT[j] do begin MoveTo(x,y); PenPat(thePat); if MacII then RGBForeColor(theClr); PenSize(hSize,vSize); TextFont(theFnum); TextSize(theFsize); TextFace(theFstyle); end; end; Procedure OffBits; { set offscreen bitmap } begin if MacII then begin if PixDraw then begin SetPort(GrafPtr(myCGrafPtr)); end; end else begin oldRgn:=NewRgn; CopyRgn(DrawWindow^.visRgn,oldRgn); RectRgn(DrawWindow^.visRgn,bmap.bounds); Wbits:=DrawWindow^.portbits; SetPortBits(bmap); end; end; Procedure OnBits; { set onscreen bitmap } begin if MacII then begin if PixDraw then begin SetPort(DrawWindow); end; end else begin CopyRgn(oldRgn,DrawWindow^.visRgn); DisposeRgn(oldRgn); SetPort(DrawWindow); SetPortBits(Wbits); end; end; Procedure DoSplatter(user:integer); var r :rect; i,xx,yy :integer; begin ClipRect(drect); with UT[user] do for i := 1 to splatSpeed do begin repeat xx := random mod SplatRad; yy := random mod SplatRad; until xx*xx+yy*yy <= SplatRad*SplatRad; xx := xx + x; yy := yy + y; SetRect(r,xx,yy,xx+hSize,yy+vSize); PaintRect(r); OffBits; PaintRect(r); OnBits; end; ClipRect(drawWindow^.portRect); end; Procedure DoRect(utnum:integer;r:rect;optDown:boolean); { handle rect packets } begin Debug('DoRect'); with UT[utnum] do case theTool of TRect: begin if not optDown then PenPat(black); FrameRect(r); OffBits; FrameRect(r); OnBits; end; TFRect: begin PaintRect(r); OffBits; PaintRect(r); OnBits; if not optDown then begin PenPat(black); FrameRect(r); OffBits; FrameRect(r); OnBits; end; end; TOval: begin if not optDown then PenPat(black); FrameOval(r); OffBits; FrameOval(r); OnBits; end; TFOval: begin PaintOval(r); OffBits; PaintOval(r); OnBits; if not optDown then begin PenPat(black); FrameOval(r); OffBits; FrameOval(r); OnBits; end; end; end; end; Procedure DoDrag(utnum,dx,dy:integer); { handle drag packets } var pt :point; r :rect; begin Debug('DoDrag'); with UT[utnum] do case theTool of Tbrush: begin if theMode=connect then begin GetPen(pt); LineTo(dx,dy); OffBits; MoveTo(pt.h,pt.v); LineTo(dx,dy); OnBits; end else begin MoveTo(dx,dy); Line(0,0); OffBits; MoveTo(dx,dy); Line(0,0); OnBits; end; x := dx; y := dy; end; Terase: begin penPat(white); if theMode=connect then begin GetPen(pt); LineTo(dx,dy); OffBits; MoveTo(pt.h,pt.v); LineTo(dx,dy); OnBits; end else begin MoveTo(dx,dy); Line(0,0); OffBits; MoveTo(dx,dy); Line(0,0); OnBits; end; x := dx; y := dy; end; TSplatter: begin x := dx; y := dy; DoSplatter(utnum); end; end; end; Procedure SendMyInfo(id:integer); { send UT entry to node <id> } begin Debug('SendMyInfo'); with LAPwbuf do begin theType := sendinfo; info := UT[0]; end; SendLAP(id); end; Procedure DebugLAPType(t:MSGType); begin case t of paintMode: Debug(' paintMode'); alpha: Debug(' alpha'); settool: Debug(' settool'); eraseall: Debug(' eraseall'); setpat: Debug(' setpat'); setcolor: Debug(' setcolor'); setpen: Debug(' setpen'); setfont: Debug(' setfont'); setpos: Debug(' setpos'); drag: Debug(' drag'); rectpck: Debug(' rect'); rqinfo: Debug(' rqinfo'); sendinfo: Debug(' sendinfo'); end; end; Procedure ExecMessage(var msg:LAPMsg); { handle a LAP message } var j :integer; pt :point; savePort :GrafPtr; begin Debug('ExecMessage'); changed := true; with msg do if theType=rqInfo then { handle rqInfo requests } begin SendMyInfo(id); DebugLAPType(theType); end else { handle graphics commands } begin GetPort(savePort); SetPort(DrawWindow); j := FindUser(id); { get index into user table } if j>=0 then begin SetUserState(j); { set user's port state } with UT[j] do begin DebugLAPType(theType); case theType of paintMode: theMode := mode; alpha: begin GetPen(pt); DrawChar(ch); OffBits; MoveTo(pt.h,pt.v); DrawChar(ch); OnBits; GetPen(pt); x := pt.h; y := pt.v; end; eraseall: begin eraseRect(drect); OffBits; eraseRect(drect); OnBits; end; settool: theTool := tool; setpat: thePat := pat; setcolor:theClr := clr; setpen: begin hSize := px; vSize := py; end; setfont: begin theFnum := fnum; theFsize := fsize; theFstyle := fstyl; end; setpos: begin x := mx; y := my; end; drag: DoDrag(j,cx,cy); rectpck: DoRect(j,rct,optDown); setSplat: begin splatRad := sRad; splatSpeed := sSpeed; end; sendinfo: begin UT[j] := info; Debug(' sendInfo received'); end; end; time := tickCount; { user is active } end; end else Debug(' msg not executed'); SetPort(savePort); end; end; Procedure CheckQueue; { execute packet commands from incoming queue } var msg :LAPMsg; begin if polling then CheckRead; if xDequeue(msg) then { incoming queue } ExecMessage(msg); end; Procedure SendLAP(who:byte); { send a LAP Packet to node <id> } var sz :longint; begin Debug('SendLAP'); DebugLAPType(LAPwbuf.theType); { %%%%%%%%%% THIS NEEDS TO BE RECALCULATED! %%%%%%%%%%% } case LAPwbuf.theType of paintMode,alpha,settool: sz := 2; eraseall: sz := 0; setpat: sz := sizeof(pattern); setcolor: sz := sizeof(RGBColor); setfont: sz := sizeof(style) + 4; setpos,setpen,drag: sz := 4; rectpck: sz := sizeof(rect)+2; sendinfo: sz := sizeof(UserTableRec); setSplat: sz := 4; end; sz := sizeof(MSGType)+4+sz; { LAP packet size } sz := sizeof(LAPMsg); { <--- DEBUGGING ONLY } with LAPwbuf do { set up LAP packet size, sender id } begin id := myNode; size[0] := sz div 256; size[1] := sz mod 256; end; with LAPwh^^ do begin lapAddress.lapProtType := OurType; { protocol type } lapAddress.dstNodeID := who; { destination node } lapReqCount := sz; { packet size } lapDataPtr := @LAPwbuf; { packet data pointer } end; err := LAPWrite(LAPwh,false); { send LAP packet } DoErr(70); if LAPwbuf.theType < rqInfo then { don't want to execute rqInfo or sendInfo locally } ExecMessage(LAPwbuf); { execute message locally } end; Procedure CheckRead; var destnode :integer; begin SetUpA5; err := LAPrh^^.abResult; if err=0 then begin Debug('CheckRead: msg rcvd'); DebugLAPType(LAPrbuf.theType); destNode := LAPrh^^.lapAddress.dstNodeID; if (destNode=255) or (destNode=myNode) then xEnqueue(LAPrbuf); end; if err<>1 then begin with LAPrh^^ do begin lapAddress.lapProtType := OurType; lapReqCount := Sizeof(LAPMsg); lapDataPtr := @LAPrbuf; end; err := LAPRead(LAPrh,true); DoErr(5000); end; myTask.vblCount := VBLCnt; RestoreA5; end; Procedure SetUpRead; begin with LAPrh^^ do begin lapAddress.lapProtType := OurType; lapReqCount := Sizeof(LAPMsg); lapDataPtr := @LAPrbuf; end; err := LAPRead(LAPrh,true); DoErr(71); if not polling then begin with myTask do begin qType := ord(vType); vblAddr := @CheckRead; vblCount := VBLCnt; vblPhase := VBLCnt div 2 + 1; end; err := VInstall(@myTask); DoErr(500); end; end; Procedure DisplayPatterns; var i :integer; begin for i := 1 to 8 do FillRect(toolRects[i+12],thePatterns[i]); FillRect(curPatRect,thePatterns[curPat]); end; Procedure DisplayColors; var i :integer; begin PenNormal; for i := 1 to 8 do begin RGBForeColor(theColors[i]); PaintRect(toolRects[i+12]); end; RGBForeColor(theColors[curColor]); PaintRect(curPatRect); end; Procedure DrawPalette; var r :rect; begin SetPort(DrawWindow); DrawPicture(palette,prect); with UT[0] do begin InvertRect(toolRects[theTool]); if not theMode then with toolRects[theTool] do begin PenMode(PatXOR); PenPat(ltgray); PaintRect(toolRects[Tspray]); PenNormal; end; end; PenMode(PatXOR); PenPat(ltgray); if PatternsUp then begin PaintRect(toolRects[Tcolor]); PenNormal; DisplayPatterns; end else begin PaintRect(toolRects[Tpat]); PenNormal; DisplayColors; end; with vSizeRect,UT[0] do SetRect(r,left,top+(vSize-1)*2,right,top+vSize*2); InvertRect(r); with hSizeRect,UT[0] do SetRect(r,left,top+(hSize-1)*2,right,top+hSize*2); InvertRect(r); { draw current tools, modes, pattern/color, pensize } end; Procedure OpenBitMap(r:rect); { create offscreen bitmap } var pb :Bitmap; xx,yy,sn :Longint; i :Integer; saveGDevice :GDHandle; maxGDevice :GDHandle; theDepth :Integer; offRowBytes :Longint; sizeOfOff :LongInt; begin if MacII then begin if PixDraw then begin { * Pix Map Mak'in * } saveGDevice:=GetGDevice; maxGDevice:=GetMaxDevice(screenBits.Bounds); SetGDevice(maxGDevice); myCGrafPtr:=@myCGrafPort; OpenCPort(myCGrafPtr); theDepth:=myCGrafPtr^.portPixMap^^.pixelSize; with r do begin offRowBytes:=((((theDepth*(right-left))+15))DIV 16)*2; sizeOfOff:=LongInt(bottom-top)*offRowBytes; end; with myCGrafPtr^.portPixMap^^ do begin DisposPtr(baseAddr); baseAddr:=NewPtr(sizeOfOff); rowBytes:=offRowBytes+$8000; bounds:=r; end; ourCMHandle:=maxGDevice^^.gdpMap^^.pmTable; err:=HandToHand(handle(ourCMHandle)); If Err<>NoErr then SysBeep(1); {$R-} with ourCMHandle^^ do begin for i:=0 to ctSize do ctTable[i].value:=i; transIndex:=BAND(transIndex,$7FFF); end; {$R+} myCGrafPtr^.portPixMap^^.pmTable:=ourCMHandle; bmap:=BitMapPtr(myCGrafPtr^.portPixMap^)^; Wbits:=BitMapPtr(CGrafPtr(DrawWindow)^.portPixMap^)^; SetPort(GrafPtr(myCGrafPtr)); EraseRect(thePort^.portRect); SetPort(DrawWindow); SetGDevice(saveGDevice); end; end else begin with r do begin xx := right-left; yy := bottom-top; end; sn := ((xx+15) div 16)*2*yy; with bmap do begin bounds := r; rowBytes := ((xx+15) div 16)*2; BaseAddr := NewPtr(sn); end; pb := DrawWindow^.portbits; SetPortBits(bmap); ClipRect(r); RectRgn(DrawWindow^.visRgn,r); EraseRect(r); SetPortBits(pb); ClipRect(DrawWindow^.portRect); RectRgn(DrawWindow^.visRgn,DrawWindow^.portRect); Wbits:=DrawWindow^.portbits; end; end; Procedure OpenDrawWindow; { initialize drawing window } var r :rect; begin if MacII then DrawWindow := GetNewCWindow(129,nil,pointer(-1)) else DrawWindow := GetNewWindow(129,nil,pointer(-1)); SetPort(DrawWindow); dRect := DrawWindow^.portrect; { drawing area } drect.left := dRect.left + 46; { make room for palette } setRect(r,0,0,576,720); OpenBitMap(r); prect := palette^^.picFrame; OffsetRect(prect,-prect.left,-prect.top); { palette bounds } DrawPalette; end; Procedure ChangeTool(NewTool:Integer); { set a new tool } begin with LAPwBuf do begin theType := setTool; tool := NewTool; end; SendLap(255); end; Function DoSizeTool(pt:point;r:rect;cur:integer):integer; var x :integer; r2 :rect; begin repeat x := (pt.v-r.top) div 2; if x<1 then x := 1 else if x>16 then x := 16; if x<>cur then begin SetRect(r2,r.left,r.top+(cur-1)*2,r.right,r.top+cur*2); InvertRect(r2); cur := x; SetRect(r2,r.left,r.top+(cur-1)*2,r.right,r.top+cur*2); InvertRect(r2); end; GetMouse(pt); until MyGetNextEvent(mUpMask,myEvent); DoSizeTool := cur; end; procedure PatternEditor(VAR myPat:Pattern); var dlg : DialogPtr; aPat : Pattern; myEvent : EventRecord; done : Boolean; draw : Boolean; dh,dv : Integer; patRect : Rect; patEdit : Rect; tRect : Rect; savePort : GrafPtr; function GetBitRect(index:Integer):Rect; begin dh:=(index mod 8)*10; dv:=(index Div 8)*10; with tRect do begin left:=patEdit.left+dh; right:=left+10; top:=patEdit.top+dv; bottom:=top+10; end; InsetRect(tRect,1,1); GetBitRect:=tRect; end; procedure InitPatBits; var i : Integer; begin for i:=0 to 63 do if BitTst(@aPat,i) then FillRect(GetBitRect(i),Black) else FillRect(GetBitRect(i),White); end; function GetBitPos(pt:point):integer; begin dh:=pt.h-patEdit.left; dh:=dh div 10; dv:=pt.v-patEdit.top; dv:=dv div 10; GetBitPos:=dv*8+dh; end; procedure EditPatClick(pt:point;firstOne:Boolean); var index : integer; begin index:=GetBitPos(pt); if firstOne then begin if BitTst(@aPat,index) then draw:=false else draw:=true; end; if draw then begin FillRect(GetBitRect(index),Black); BitSet(@aPat,index); end else begin FillRect(GetBitRect(index),White); BitClr(@aPat,index); end; FillRect(patRect,aPat); end; begin GetPort(savePort); aPat:=myPat; dlg:=GetNewDialog(1000,Nil,Pointer(-1)); HiliteButton(dlg); done:=false; GetDItem(dlg,3,iType,iTem,patEdit); tRect:=patEdit; InsetRect(tRect,-1,-1); FrameRect(tRect); GetDItem(dlg,4,iType,iTem,patRect); tRect:=patRect; InsetRect(tRect,-1,-1); FrameRect(tRect); FillRect(patRect,aPat); InitPatBits; Repeat CheckQueue; If MyGetNextEvent(everyEvent,myEvent) then If isDialogEvent(myEvent) then if DialogSelect(myEvent,myWindow,itemHit) then Case itemHit of Ok,Cancel:Done:=True; 3: with myEvent do begin GlobalToLocal(where); EditPatClick(where,true); Repeat GetMouse(where); if PtInRect(where,patEdit) then EditPatClick(where,false); CheckQueue; Until Not StillDown; end; end;{Case} Until done; if ItemHit=Ok then myPat:=aPat; DisposDialog(dlg); SetPort(savePort); end; Procedure SetupCursor; var savebits,bm :bitmap; r :rect; begin with UT[0] do case theTool of Tbrush: if MacII then begin SetCursor(arrow); { * For now, should manipulate color cursor * } end else begin SetRect(bm.bounds,0,0,16,16); bm.baseAddr := @theCurs; bm.rowBytes := 2; saveBits := drawWindow^.portbits; SetPortBits(bm); EraseRect(bm.bounds); with UT[0] do SetRect(r,0,0,hSize,vSize); FillRect(r,black); SetPortBits(saveBits); SetCursor(theCurs); end; TSplatter: SetCursor(theSprayer^^); Tletters: SetCursor(GetCursor(iBeamCursor)^^); Terase: if MacII then begin SetCursor(arrow); { * For now, should manipulate color cursor * } end else begin SetRect(bm.bounds,0,0,16,16); bm.baseAddr := @theECurs; bm.rowBytes := 2; saveBits := drawWindow^.portbits; SetPortBits(bm); FillRect(bm.bounds,white); with UT[0] do SetRect(r,0,0,hSize,vSize); FrameRect(r); bm.baseAddr := @theECurs.mask; EraseRect(bm.bounds); FillRect(r,black); SetPortBits(saveBits); SetCursor(theECurs); end; Trect..Tfoval: SetCursor(GetCursor(crossCursor)^^); end; updateCurs := false; end; Procedure FixCursor; { handle cursor updating } var pt :point; begin If windowPeek(FrontWindow)^.windowKind>-1 then begin GetMouse(pt); if (PtInRect(pt,dRect) and arrowCurs) or updateCurs then begin SetupCursor; arrowCurs := false; end else if (not PtInRect(pt,dRect)) and (not arrowCurs) then begin SetCursor(arrow); arrowCurs := true; end; end; end; Procedure SavePic(saveas:boolean); { save file } var where :point; reply :SFReply; err :integer; ar,dr :packed array [0..75] of byte; n,l :longint; i,j,ref :integer; r,rr :rect; bm :bitmap; srcPtr :ptr; dstPtr :ptr; h :handle; s :str255; procedure ChkErr; begin if err <> 0 then DoErr(err); end; begin if not saved then saveas := true; if saveas then begin SetPt(where,50,50); GetWTitle(drawWindow,s); SFPutFile(where,'Save document as:',s,@idleFilter,reply); BeginUpdate(DrawWindow); DrawContents; DrawPalette; EndUpdate(DrawWindow); end else with reply do begin good := true; GetWTitle(drawWindow,s); fname := s; vRefNum := fVref; end; if reply.good then begin err := SetVol(nil,reply.vRefNum); ChkErr; if saveas then begin err := FSDelete(reply.fname,reply.vRefnum); if (err<>noErr) and (err<>fnfErr) then ChkErr; err := Create(reply.fname,reply.vRefnum,'JPNT','PNTG'); ChkErr; end; err := FSOpen(reply.fname,reply.vrefnum,ref); ChkErr; if saveas then begin err := SetEOF(ref,512); ChkErr; err := SetFPos(ref,fsFromStart,0); ChkErr; l := 0; n := 4; err := FSWrite(ref,n,@l); { write version # 0 } ChkErr; end; err := SetFPos(ref,fsFromStart,512); ChkErr; with bm do begin SetRect(bounds,0,0,72*8,1); baseAddr := @ar; rowbytes := 72; end; SetRect(rr,0,0,576,1); for i := 0 to 719 do begin setRect(r,0,i,576,i+1); CopyBits(bmap,bm,r,rr,SrcCopy,nil); srcPtr := @ar; dstPtr := @dr; PackBits(srcPtr,dstPtr,72); n := ord(dstPtr)-ord(@dr); err := FSWrite(ref,n,@dr); ChkErr; CheckQueue; end; err := FSClose(ref); ChkErr; SetWTitle(drawWindow,reply.fname); fVref := reply.vRefnum; changed := false; saved := true; end; end; Function MySaveProc(dlg:DialogPtr;Var theEvent:EventRecord;VAR IH:Integer):Boolean; begin SetUpA5; MySaveProc:=false; CheckQueue; RestoreA5; end; Function Continue:Boolean; var choice : Integer; begin Continue:=true; If changed then begin choice:=NoteAlert(2000,@MySaveProc); Case Choice of 2: begin SavePic(false); If changed then Continue:=false; end; 3: Continue:=false; end; end; end; Procedure LoadPic; { load picture } var where :point; reply :SFReply; err :integer; ar :packed array [0..75] of byte; n :longint; i,j,ref :integer; r,rr :rect; bm :bitmap; srcPtr,p :ptr; dstPtr :ptr; typeList :SFTypeList; procedure ChkErr; begin if err <> 0 then DoErr(err); end; begin If not Continue then exit(LoadPic); SetPt(where,80,50); typeList[0] := 'PNTG'; SFGetFile(where,'Open document:',nil,1,typelist,@idleFilter,reply); if reply.good then begin BeginUpdate(DrawWindow); DrawContents; DrawPalette; EndUpdate(DrawWindow); err := SetVol(nil,reply.vRefNum); ChkErr; err := FSOpen(reply.fname,reply.vrefnum,ref); ChkErr; err := SetFPos(ref,fsFromStart,512); ChkErr; with bm do begin SetRect(bounds,0,0,72*8,1); baseAddr := @ar; rowbytes := 72; end; err := GetEOF(ref,n); ChkErr; n := n-512; p := NewPtr(n); srcPtr := p; err := FSRead(ref,n,srcPtr); ChkErr; SetRect(rr,0,0,576,1); for i := 0 to 719 do begin dstPtr := @ar; UnPackBits(srcPtr,dstPtr,72); setRect(r,0,i,576,i+1); CopyBits(bm,bmap,rr,r,SrcCopy,nil); CheckQueue; end; disposPtr(p); err := FSClose(ref); ChkErr; SetWTitle(drawWindow,reply.fname); fVref := reply.vRefnum; changed := false; saved := true; InvalRect(drect); end; end; Procedure FadeIn(r:rect;pat:pattern); var v,h,x,i,n :longint; begin pennormal; penpat(pat); with r do begin v := bottom-top; h := right-left; for x := 1 to h do begin n := (x*v) div h; for i := 1 to n do begin moveto(x+left,top+(i*v) div n); line(0,0); end; end; end; end; Procedure FadeOut(r:rect;pat:pattern); var v,h,x,i,n :longint; begin pennormal; penpat(pat); with r do begin v := bottom-top; h := right-left; for x := 1 to h do begin n := ((h-x)*v) div h; for i := 1 to n do begin moveto(x+left,top+(i*v) div n); line(0,0); end; end; end; end; Procedure FadeInto(r:rect;inPat,outPat:pattern); begin SysBeep(1); end; Procedure PastePicture; var PPHdl : Handle; { * Paste Picture handle * } PTHdl : Handle; { * Paste TEXT handle * } Sclen : Longint; offset : Longint; anEvent : EventRecord; PicRect : Rect; err : Longint; info : FontInfo; TEXTStr : Str255; TBox : Rect; begin err:=LoadScrap; PPHdl:=NewHandle(0); Sclen:=GetScrap(PPHdl,'PICT',offset); If Sclen<0 then begin PTHdl:=NewHandle(0); Sclen:=GetScrap(PTHdl,'TEXT',offset); If Sclen>-1 then begin GetFontInfo(info); GetiText(PTHdl,TEXTStr); with DrawWindow^.portRect,info do SetRect(TBox,left,top,left+StringWidth(TEXTStr)+1,top+ascent+descent+leading); HLock(PTHdl); PPHdl:=Handle(OpenPicture(TBox)); TextBox(PTHdl^,Sclen,TBox,teJustLeft); ClosePicture; HunLock(PTHdl); end; DisposHandle(PTHdl); end; If Sclen>-1 then begin SetCursor(ThePlacer^^); Repeat CheckQueue; Until MyGetNextEvent(mDownmask,anEvent); with anEvent do begin GlobalToLocal(where); If (what=mouseDown) & (PtinRect(where,DrawWindow^.portRect) & not (PtInRect(where,prect))) then with PicHandle(PPHdl)^^.picFrame,where do begin ClipRect(dRect); SetRect(PicRect,h,v,h+(right-left),v+(bottom-top)); DrawPicture(PicHandle(PPHdl),PicRect); OffBits; DrawPicture(PicHandle(PPHdl),PicRect); OnBits; ClipRect(DrawWindow^.portRect); end; end; updateCurs:=true; end; DisposHandle(PPHdl); end; Procedure ResizeSprayKan; var ResizeBox : Rect; CircleBox : Rect; savePort : GrafPtr; pt : Point; tStr : Str255; x,y : Integer; newRad : Integer; newSpeed : Integer; sr : Integer; { * Save radius * } procedure ShowSize(where:Point); var dx,dy,dd : Integer; begin with where do begin dx:=abs(x-h); dy:=abs(y-v); end; If dx>dy then dd:=dx else dd:=dy; If dd<sr then EraseRect(ResizeBox); sr:=dd; SetRect(CircleBox,x-dd,y-dd,x+dd,y+dd); FillOval(CircleBox,Black); newRad:=dd; end; begin GetPort(savePort); Dlg:=GetNewDialog(1001,Nil,Pointer(-1)); HiliteButton(Dlg); SetCursor(theSizer^^); newRad:=UT[0].splatRad; PenNormal; GetDItem(Dlg,5,iType,iTem,Box); newSpeed:=UT[0].splatSpeed; SetiText(iTem,Str(newSpeed)); SeliText(Dlg,5,0,255); GetDItem(Dlg,3,iType,iTem,Box); ResizeBox:=Box; InsetRect(Box,-1,-1); FrameRect(Box); sr:=newRad; with ResizeBox do begin x:=left+(right-left) Div 2; y:=top+(bottom-top) Div 2; SetRect(CircleBox,x-sr,y-sr,x+sr,y+sr); end; FillOval(CircleBox,Black); ItemHit:=0; Repeat CheckQueue; If MyGetNextEvent(everyEvent,myEvent) then If isDialogEvent(myEvent) then if DialogSelect(myEvent,Dlg,itemHit) then Case itemHit of ok: begin GetDItem(Dlg,5,iType,iTem,Box); GetiText(iTem,tStr); newSpeed:=Val(tStr); If newSpeed<1 then begin SysBeep(1); newSpeed:=1; end else if newSpeed>255 then begin SysBeep(1); newSpeed:=255; end; end; 3: with myEvent do begin GlobalToLocal(where); pt:=where; ShowSize(where); Repeat GetMouse(where); If PtinRect(where,ResizeBox) then If longInt(where)<>longInt(pt) then begin ShowSize(where); pt:=where; end; CheckQueue; Until Not StillDown; end; end; { case } Until ItemHit in [ok,cancel]; If ItemHit=ok then begin with LAPwbuf do begin theType := setSplat; sRad := newRad; sSpeed := newSpeed; end; SendLAP(255); end; DisposDialog(Dlg); SetPort(savePort); end; Procedure ToolClick(pt:point); var i,a,h,v :integer; dblClick :boolean; where :point; outColor :RGBColor; begin dblClick := (TickCount-clickTime<GetDblTime); { possible double click? } clickTime := TickCount; a := 0; for i := 1 to 20 do if ptInRect(pt,toolRects[i]) then begin a := i; leave; end; dblClick:=(a=lastTool) and dblClick; if a>0 then begin lastTool := a; case a of 1: begin { spray can } with LAPwbuf do begin theType := paintMode; mode := not UT[0].theMode; end; SendLAP(255); PenMode(PatXOR); PenPat(ltgray); PaintRect(toolRects[Tspray]); PenNormal; end; 2..9: if dblClick then case a of TErase: begin LAPwbuf.theType := eraseall; SendLAP(255); end; TSplatter: ResizeSprayKan; end else with UT[0] do { Handle new tools } if theTool<>a then begin InvertRect(ToolRects[theTool]); InvertRect(ToolRects[a]); ChangeTool(a); end; 10: begin { disk icon } end; 11,12: if (PatternsUp<>(a=11)) and MacII then { pattern/color switch } begin PenMode(PatXOR); PenPat(ltgray); PaintRect(toolRects[Tpat]); PaintRect(toolRects[Tcolor]); PenNormal; PatternsUp := not PatternsUp; if PatternsUp then DisplayPatterns else DisplayColors; end else if PatternsUp<>(a=11) then sysbeep(1); 13..20: if dblClick then begin if patternsUp then begin PatternEditor(thePatterns[a-12]); with LAPwbuf do begin theType := setpat; pat := thePatterns[a-12]; end; SendLAP(255); curPat := a-12; DisplayPatterns; end else begin { color picker } SetPt(where,0,0); { * The color picker will center itself * } if GetColor(where,'Set Pallete color to:',theColors[a-12],outColor) then begin theColors[a-12]:=outColor; with LAPwbuf do begin theType := setcolor; clr := outColor; end; SendLAP(255); end; curColor := a-12; DisplayColors; end; end else { single click } begin if PatternsUp and (curPat<>a-12) then { pattern/color selection } begin with LAPwbuf do begin theType := setpat; pat := thePatterns[a-12]; end; SendLAP(255); curPat := a-12; FillRect(curPatRect,thePatterns[curPat]); end else if not(patternsUp) and (curColor<>a-12) then begin with LAPwbuf do begin theType := setcolor; clr := theColors[a-12]; end; SendLAP(255); curColor := a-12; RGBForeColor(theColors[curColor]); PaintRect(curPatRect); end; end; end; updateCurs := true; end else if PtInRect(pt,hSizeRect) then begin v := UT[0].vSize; h := DoSizeTool(pt,hSizeRect,UT[0].hSize); with LAPwbuf do begin theType := setPen; px := h; py := v; end; SendLAP(255); updateCurs:=true; end else if PtInRect(pt,vSizeRect) then begin h := UT[0].hSize; v := DoSizeTool(pt,vSizeRect,UT[0].vSize); with LAPwbuf do begin theType := setPen; px := h; py := v; end; SendLAP(255); updateCurs := true; end; end; Function Sgn(i:integer):integer; begin if i<0 then sgn := -1 else if i>0 then sgn := 1 else sgn := 0; end; Procedure MakeRect(pt1:point); var LastPt,pt :point; x,y :integer; dx,dy :integer; r :rect; begin lastPt := pt1; with pt1 do begin x := h; y := v; end; Repeat GetMouse(Pt); if pt.h>drect.right then { pin mouse inside drect } pt.h := drect.right else if pt.h<drect.left then pt.h := drect.left; if pt.v>drect.bottom then pt.v := drect.bottom else if pt.v<drect.top then pt.v := drect.top; if longint(LastPt)<>longint(pt) then { mouse moved } { NOTE: this is faster than EqualPt } begin { --- erase old rect --- } SetRect(r,x,y,LastPt.h,LastPt.v); if x>LastPt.h then begin r.left := LastPt.h; r.right := x; end; if y>LastPt.v then begin r.top := LastPt.v; r.bottom := y; end; CopyBits(bmap,Wbits,r,r,srcCopy,nil); { flicker-matic quick fix } { --- check for shift constraint --- } if bitAnd(mods,shiftKey)<>0 then begin dx := abs(pt.h-pt1.h); dy := abs(pt.v-pt1.v); if dy<dx then pt.h := pt1.h + dy*sgn(pt.h-pt1.h) else pt.v := pt1.v + dx*sgn(pt.v-pt1.v); end; { --- calculate new rect --- } SetRect(r,x,y,pt.h,pt.v); if x>pt.h then begin r.left := pt.h; r.right := x; end; if y>pt.v then begin r.top := pt.v; r.bottom := y; end; { --- fix mistakes --- } with UT[0] do { set my user state cuz checkqueue screws it up } begin PenPat(thePat); if MacII then RGBForeColor(theClr); PenSize(hSize,vSize); end; { --- draw rect --- } case UT[0].theTool of TRect: begin if bitAnd(mods,optionKey)=0 then PenPat(black); FrameRect(r); end; TFRect: begin PaintRect(r); if bitAnd(mods,optionKey)=0 then begin PenPat(black); FrameRect(r); end; end; TOval: begin if bitAnd(mods,optionKey)=0 then PenPat(black); FrameOval(r); end; TFOval: begin PaintOval(r); if bitAnd(mods,optionKey)=0 then begin PenPat(black); FrameOval(r); end; end; end; end; LastPt := pt; CheckQueue; Until MyGetNextEvent(mupmask,myEvent); with LAPwbuf do begin theType := rectpck; { send rectpck packet } rct := r; optDown := (bitAnd(mods,optionKey)<>0); end; SendLAP(255); { send message to everyone } end; Procedure MasterClick(pt:Point); { handle mouseDown events in our window } var LastPt :Point; dx,dy :integer; mypart :integer; begin { * If a DA then get of of here * } if windowPeek(FrontWindow)^.windowKind<0 then exit(MasterClick); if PtInRect(pt,prect) then { click in palette } ToolClick(pt) else begin if UT[0].theTool in [TRect..TFOval] then MakeRect(pt) else begin with LAPwbuf do begin theType := setpos; { send setpos packet } mx := pt.h; my := pt.v; end; SendLAP(255); { send setpos packet to everyone } Repeat GetMouse(Pt); if pt.h>drect.right then { pin mouse inside drect } pt.h := drect.right else if pt.h<drect.left then pt.h := drect.left; if pt.v>drect.bottom then pt.v := drect.bottom else if pt.v<drect.top then pt.v := drect.top; if (longint(LastPt)<>longint(Pt)) | (UT[0].TheTool=Tsplatter) then { mouse moved } { NOTE: this is faster than EqualPt } begin with LAPwbuf do begin theType := drag; { send drag packet } cx := pt.h; cy := pt.v; end; SendLAP(255); { send message to everyone } LastPt := Pt; end; CheckQueue; Until MyGetNextEvent(mupmask,myevent); end; end; end; Procedure MasterKey(theChar:char); begin if UT[0].theTool = Tletters then if theChar>=' ' then begin with LAPwbuf do begin theType := alpha; ch := theChar; end; SendLAP(255); end; end; Procedure ChangeFont; var s :str255; i :integer; begin CheckItem(myMenus[fontMenu],theFontidx,false); theFontidx:=theItem; GetItem(mymenus[fontMenu],theItem,s); GetFNum(s,theItem); CheckItem(myMenus[fontMenu],theFontidx,true); with UT[0] do if theItem<>theFNum then begin with LAPwbuf do begin theType := setfont; fnum := theItem; fsize := theFSize; fstyl := theFstyle; end; SendLAP(255); end; for i:=1 to 9 do begin GetItem(myMenus[sizeMenu],i,s); if RealFont(theItem,Val(s)) then SetItemStyle(myMenus[sizeMenu],i,[Outline]) else SetItemStyle(myMenus[sizeMenu],i,[]); end; end; procedure ChangeStyle; const plainItem = 1; var markChar :char; StyleArray :packed array [1..7] of styleitem; i :integer; CStyle :style; begin CStyle:=UT[0].theFStyle; StyleArray[1]:=Bold; StyleArray[2]:=Italic; StyleArray[3]:=Underline; StyleArray[4]:=Outline; StyleArray[5]:=Shadow; StyleArray[6]:=Extend; StyleArray[7]:=Condense; If theitem=plainItem then begin CheckItem(myMenus[styleMenu],1,true); for i:=2 to 8 do CheckItem(myMenus[styleMenu],i,false); CStyle:=[]; end else begin CheckItem(myMenus[styleMenu],1,false); GetItemMark(myMenus[styleMenu],theitem,markChar); If markChar=chr(noMark) then begin CStyle:=CStyle+[StyleArray[theitem-1]]; CheckItem(myMenus[styleMenu],theitem,True); end else begin CheckItem(myMenus[styleMenu],theitem,false); CStyle:=CStyle-[StyleArray[theitem-1]]; If CStyle=[] then CheckItem(myMenus[styleMenu],1,true); end; end; if CStyle<>UT[0].theFStyle then begin with LAPwbuf do begin theType := setfont; with UT[0] do begin fNum := theFNum; fSize := theFSize; fStyl := CStyle; end; end; SendLAP(255); end; end; Procedure ChangeSize; var s :str255; begin if theSizeidx<>theItem then begin CheckItem(myMenus[sizeMenu],theSizeidx,false); CheckItem(myMenus[sizeMenu],theItem,true); theSizeidx:=theItem; GetItem(mymenus[sizeMenu],theItem,s); theItem:=Val(s); with UT[0] do begin with LAPwbuf do begin theType := setfont; fnum := theFNum; fsize := theItem; fstyl := theFstyle; end; SendLAP(255); end; end; end; Procedure DrawContents; { redraw drawing } begin SetPort(DrawWindow); CopyBits(bmap,wbits,drect,drect,SrcCopy,Nil); end; Procedure PrintPic; { print a document } var GetOutEh : Boolean; temphPrint : THPrint; err : OSErr; savePort : GrafPtr; myPrPort : TPPrPort; myStRec : TPrStatus; i : Integer; begin temphPrint:=hPrint; err:=HandToHand(handle(temphPrint)); if Err<>NoErr then begin SysBeep(1); exit(PrintPic); end; PrOpen; if PrJobDialog(temphPrint) then begin GetOutEh:=false; DisposHandle(handle(hPrint)); If MemError<>NoErr then SysBeep(1); hPrint:=temphPrint; err:=HandToHand(handle(hPrint)); If Err<>NoErr then begin SysBeep(1); GetOutEh:=true; end; end else GetOutEh:=true; PrClose; DisposHandle(handle(temphPrint)); if GetOutEh then exit(PrintPic); BeginUpdate(DrawWindow); DrawContents; DrawPalette; EndUpdate(DrawWindow); GetPort(savePort); for i:=1 to hPrint^^.PrJob.iCopies do begin PrOpen; If PrError=noErr then begin myPrPort:=PrOpenDoc(hPrint,Nil,Nil); If PrError=noErr then begin PrOpenPage(myPrPort,Nil); If PrError=noErr then CopyBits(bmap,myPrPort^.gPort.portBits,bmap.bounds,bmap.bounds,SrcCopy,Nil); PrClosePage(myPrPort); end; end; If PrError=noErr then PrCloseDoc(myPrPort); If (hPrint^^.prJob.bjDocLoop=bSpoolLoop) and (PrError=NoErr) then PrPicFile(hPrint,Nil,Nil,Nil,myStRec); PrClose; end; SetPort(savePort); end; Procedure DoMyUpdate; var savePort :grafPtr; tempWindow :windowPtr; begin tempWindow:=WindowPtr(myEvent.message); GetPort(savePort); SetPort(tempWindow); BeginUpdate(tempWindow); if tempWindow=DrawWindow then begin DrawContents; DrawPalette; end; EndUpdate(tempWindow); SetPort(savePort); end; Procedure DoJamAbout; const picID = 999; var AboutWindow : WindowPtr; AboutPict : PicHandle; AboutRect : Rect; AboutEvent : Eventrecord; SavePort : GrafPtr; x1,y1,x2,y2 : Integer; begin GetPort(SavePort); AboutPict:=PicHandle(GetResource('PICT',999)); RsrcErr; with ScreenBits.Bounds do begin x1:=right-left; y1:=bottom-top; end; with AboutPict^^.picFrame do begin x2:=right-left; y2:=bottom-top; end; SetRect(AboutRect,1,1,x2,y2); AboutWindow:=NewWindow(Nil,AboutRect,'',false,1,Pointer(-1),false,0); MoveWindow(AboutWindow,(x1-x2) Div 2,(y1-y2) Div 2,true); ShowWindow(AboutWindow); SetPort(AboutWindow); with AboutPict^^.picFrame do SetRect(AboutRect,0,0,right-left,bottom-top); DrawPicture(AboutPict,AboutRect); Repeat CheckQueue; Until MyGetNextEvent(mdownMask+keyDownMask+AutoKeyMask,AboutEvent); ReleaseResource(handle(AboutPict)); RsrcErr; DisposeWindow(AboutWindow); SetPort(SavePort); end; Procedure DoCommand(mResult:longint); { handle menu commands } var name : Str255; begin theMenu := HiWord(mResult); theItem := LoWord(mResult); if BitAnd(myEvent.modifiers,CmdKey) <> 0 then HiliteMenu(theMenu); case theMenu of 255: If theItem <> 1 then begin GetItem(myMenus[appleMenu],theItem,name); refnum:=OpenDeskAcc(name); end else If WindowPeek(FrontWindow)^.windowKind > 0 then DoJamAbout else SysBeep(1); 256: case theItem of { main menu } 1: LoadPic; 2: SavePic(false); 3: SavePic(true); { ------- } 5: DoPageSetUp; 6: PrintPic; { ------- } 8: If Continue then doneFlag:=true; 10:begin PrDebug := not PrDebug; if PrDebug then begin PrCtlCall(iPrDevCtl,$00010000,0,0); debug('---> Debug transcript follows'); end; end; end; 257: ChangeFont; 258: ChangeSize; 259: ChangeStyle; 260: case theItem of 1: FadeIn(drawWindow^.portRect,UT[0].thePat); 2: FadeOut(drawWindow^.portRect,UT[0].thePat); 3: FadeInto(drawWindow^.portRect,black,white); end; end; HiliteMenu(0); end; Procedure InitTables; { initialize User Table, Queue } var i :integer; begin with PQ do { empty queue } begin head := 0; tail := 0; end; with UT[0] do begin id := myNode; theTool := dTool; { default tool } theMode := dMode; { default mode } thePat := black; { default pattern } theClr := theColors[dColor]; { default to black } hSize := dPen; { default pensize } vSize := dPen; { default pensize } theFnum := applFont; { default text font } theFsize := dSize; { default text size } theFstyle := dStyle; { default text style } x := 100; { somewhere on the screen } y := 50; splatSpeed := dsplatterCount; { default speed } splatRad := dsplatRad; { default radius } { time needs no initialization } end; for i := 1 to maxUsers do begin UT[i] := UT[0]; UT[i].id := -1; { invalidate all users } end; end; Procedure ReadPatCol; { read patterns and colors into memory } var RGBColors :CHandle; i :integer; begin for i:=1 to 8 do GetIndPattern(thePatterns[i],128,i); RGBColors:=CHandle(GetResource('CLRS',128)); RsrcErr; theColors:=RGBColors^^; ReleaseResource(handle(RGBColors)); RsrcErr; end; Procedure InitGlob; { init globals, user table, etc. } const UnImplTrapNum = $9F; { * Unimplemented trap * } WaitNextEventTrapWord = $60; var i,j :integer; Rom,Machine :integer; theWorld :SysEnvRec; begin { * Get the world, so to speak * } if SysEnvirons(1,theWorld)<>envNotPresent then begin MultiFinderRunning:=(theWorld.machineType>=0) & (NGetTrapAddress(WaitNextEventTrapWord,ToolTrap)<>NGetTrapAddress(UnImplTrapNum,ToolTrap)); ColorQDrawImplm:=theWorld.hasColorQD; end else begin MultiFinderRunning:=false; ColorQDrawImplm:=false; end; Environs(Rom,Machine); if Machine=2 then MacII:=true else MacII:=false; PixDraw:=false; { * Controls if mac II pix map shit is working or not * } MacII:=false; PrDrvrOpen; PrDebug := false; { *** for debugging only *** } err := MPPOpen; { open Appletalk driver } if err<>noErr then begin SysBeep(1); exitToShell; end; err := GetNodeAddress(myNode,myNet); { who am I? I don't know } if err<>noErr then begin SysBeep(1); exitToShell; end; err := LapOpenProtocol(OurType,nil); { open our protocol type } if err<>noErr then begin SysBeep(1); exitToShell; end; LAPrh := ABRecHandle(newHandle(lapSize)); { handle for LAP reads } LAPwh := ABRecHandle(newHandle(lapSize)); { handle for LAP writes } HLock(handle(LAPrh)); HLock(handle(LAPwh)); hPrint:=THPrint(NewHandle(SizeOf(TPrint))); SetUpRead; { set up initial LAPRead } palette := PicHandle(GetResource('PICT',1000)); RsrcErr; jamPic := PicHandle(GetResource('PICT',1001)); RsrcErr; for i := 1 to 20 do begin j := (i-1) div 2; if odd(i) then SetRect(ToolRects[i],0,20*j,22,20*(j+1)-1) else SetRect(ToolRects[i],23,20*j,45,20*(j+1)-1); end; SetRect(curPatRect,3,203,42,225); SetRect(hSizeRect,0,231,21,266); SetRect(vSizeRect,23,231,44,266); PatternsUp := true; curPat := 1; curColor := 1; ReadPatCol; PatternsUp:=true; for i := 0 to 15 do theCurs.mask[i] := 0; setPt(theCurs.hotspot,0,0); setPt(theECurs.hotspot,0,0); arrowCurs := true; updateCurs := false; InitTables; OpenDrawWindow; textMode(SrcCopy); clickTime := 0; { set up doubleclick variables } lastTool := -1; DoneFlag := false; theSizeidx := 3; changed := false; theSizer:=GetCursor(1000); theHand:=GetCursor(1001); thePlacer:=GetCursor(1002); theSprayer:=GetCursor(1003); end; Procedure CleanUp; { All of this isn't really necessary except for closing our protocol type. The application heap will be flushed anyway, but we ought to set a good example.... } begin PrDrvrClose; if LAPrh^^.abResult=1 then { stop LAP read if still in progress } begin err := LAPRdCancel(LAPrh); DoErr(1004); end; if not polling then begin err := VRemove(@myTask); { remove VBLTask } DoErr(1005); end; err := LAPCloseProtocol(OurType); { !! close protocol !! } DoErr(1000); err := MPPClose; { close AppleTalk driver } DoErr(1002); DisposHandle(handle(LAPrh)); DisposHandle(handle(LAPwh)); releaseResource(handle(palette)); RsrcErr; releaseResource(handle(jamPic)); RsrcErr; if PixDraw then begin end else DisposPtr(bmap.baseAddr); end; procedure _DataInit;EXTERNAL; begin UnloadSeg(@_DataInit); { * Get rid of MPW's init code * } FlushEvents(everyEvent,0); InitGraf(@thePort); InitFonts; TEInit; InitWindows; InitDialogs(Nil); InitCursor; SetUpMenus; InitGlob; Repeat FixCursor; CheckQueue; { something for us to do while we idle } if MyGetNextEvent(everyEvent,myEvent) then with myEvent do case what of mouseDown: begin mods := modifiers; code := FindWindow(where,tempWindow); case code of inMenuBar: DoCommand(MenuSelect(where)); InSysWindow: SystemClick(myEvent,tempWindow); inContent,InDrag: if tempWindow <> frontWindow then begin SelectWindow(tempWindow); SetPort(tempWindow); end else if FrontWindow=DrawWindow then begin GlobalToLocal(where); MasterClick(where); end; end; end; keyDown, autoKey: begin theChar := chr(BitAnd(message,255)); if BitAnd(modifiers,CmdKey)<>0 then begin if theChar in ['v','V'] then PastePicture else DoCommand(MenuKey(theChar)) end else MasterKey(theChar); end; updateEvt: DoMyUpdate; activateEvt: if Odd(modifiers) then begin tempWindow:=WindowPtr(message); SetPort(tempWindow); If tempWindow=DrawWindow then begin updateCurs:=true; { * Remove Edit menu/ we don't use it, but DAs might * } If FileMenuPresent then begin FileMenuPresent:=false; DeleteMenu(261); DrawMenuBar; end; end else SetCursor(arrow); end else begin { * If our about window caused it then give them an Edit menu * } if (WindowPtr(message)=DrawWindow) & (not FileMenuPresent) & (windowPeek(FrontWindow)^.windowKind<0) then begin FileMenuPresent:=true; InsertMenu(myMenus[EditMenu],257); DrawMenuBar; end; end; end; Until doneflag; CleanUp; SetCursor(GetCursor(WatchCursor)^^); end.